home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / rectangle < prev   
Encoding:
Text File  |  1988-05-28  |  3.7 KB  |  111 lines  |  [TEXT/CCL ]
  1. ; rectangle manager
  2. ; from Smalltalk-80, the language and its implementation.
  3. ; Adele Goldberg and David Robson. Addison-Wesley, pp. 344-349
  4. ; implemented in Allegro Common Lisp by Jean-Pascal J. LANGE.
  5. ; © Copyright 1988 Jean-Pascal J. LANGE.
  6.  
  7. (proclaim '(optimize (speed 3)
  8.             (space 0)
  9.             (safety 0)
  10.             (compilation-speed 0) ))
  11.  
  12. (eval-when
  13.   (compile eval load)
  14.   (require 'quickDraw)
  15.   (require 'records) )
  16.  
  17. (proclaim '(object-variable wptr)) ; from *window* class
  18.  
  19. (deFun newRectangle
  20.        (&key
  21.         (top nil)
  22.         (left nil)
  23.         (topLeft nil)
  24.         (bottom nil)
  25.         (right nil)
  26.         (bottomRight nil) )
  27.   (let ((rectangle (make-record 'rect)))
  28.     (if topLeft
  29.       (cond (top
  30.              (error "Conflicting coordinates: ~
  31.                      top (~A) and topLeft (~A)"
  32.                     top (point-string topLeft) ) )
  33.             (left
  34.              (error "Conflicting coordinates: ~
  35.                      left (~A) and topLeft (~A)"
  36.                     left (point-string topLeft) ) )
  37.             (t (rSet rectangle rect.topLeft topLeft)) )
  38.       (progn
  39.         (if top (rSet rectangle rect.top top))
  40.         (if left (rSet rectangle rect.left left)) ) )
  41.     (if bottomRight
  42.       (cond (bottom
  43.              (error "Conflicting coordinates: ~
  44.                      bottom (~A) and bottomRight (~A)"
  45.                     bottom (point-string bottomRight) ) )
  46.             (right
  47.              (error "Conflicting coordinates: ~
  48.                      right (~A) and bottomRight (~A)"
  49.                     right (point-string bottomRight) ) )
  50.             (t (rSet rectangle rect.bottomRight bottomRight)) )
  51.       (progn
  52.         (if bottom (rSet rectangle rect.bottom bottom))
  53.         (if right (rSet rectangle rect.right right)) ) )
  54.     rectangle ) )
  55.  
  56. (deFun leftRightTopBottom (left right top bottom)
  57.   (newRectangle :top top :left left :bottom bottom :right right) )
  58.  
  59. (deFun originCorner (origin corner)
  60.   (newRectangle :topLeft origin :bottomRight corner) )
  61.  
  62. (deFun originExtent (origin extent)
  63.   (newRectangle :topLeft origin
  64.                 :bottomRight (add-points origin extent) ) )
  65.  
  66. (deFun originRect (rectangle)
  67.   (rRef rectangle rect.topLeft) )
  68.  
  69. (deFun corner (rectangle)
  70.   (rRef rectangle rect.bottomRight) )
  71.  
  72. (deFun center (rectangle)
  73.   (let ((extent (extent rectangle)))
  74.     (add-points (originRect rectangle)
  75.                 (make-point (round (point-h extent) 2.0)
  76.                             (round (point-v extent) 2.0) ) ) ) )
  77.  
  78. (deFun extent (rectangle)
  79.   (subtract-points (corner rectangle) (originRect rectangle)) )
  80.  
  81. (deFun setOrigin (rectangle origin)
  82.   (rSet rectangle rect.topLeft origin) )
  83.  
  84. (deFun setCorner (rectangle corner)
  85.   (rSet rectangle rect.bottomRight corner) )
  86.  
  87. (deFun setCenter (rectangle aPoint)
  88.   ; move the rectangle so it is centered on the point,
  89.   ; but keep the width and height unchanged
  90.   (let ((extent (extent rectangle)))
  91.     (setOrigin rectangle
  92.                (add-points (originRect rectangle)
  93.                            (subtract-points aPoint
  94.                                             (center rectangle) ) ) )
  95.     (setCorner rectangle
  96.                (add-points (originRect rectangle) extent) ) ) )
  97.  
  98. (deFun border (rectangle width &optional (window (front-window)))
  99.   (let* ((oldPenState (ask window (pen-state))))
  100.     (with-port (ask window wptr)
  101.       (ask window (pen-normal)
  102.            (set-pen-size (make-point width width))
  103.            (frame-rect rectangle)
  104.            (set-pen-state oldPenState) ) )
  105.     (dispose-record oldPenState) ) )
  106.  
  107. (deFun erase (rectangle &optional (window (front-window)))
  108.   (ask window (erase-rect rectangle)) )
  109.  
  110. (deFun invertRect (rectangle &optional (window (front-window)))
  111.   (ask window (invert-rect rectangle)) )